home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / trace.tcl < prev    next >
Encoding:
Text File  |  1995-11-06  |  3.3 KB  |  145 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # simple stuff to support interactive variable tracing
  8. #  - print value any time global variable changes
  9.  
  10. # Basic Usage:
  11. #  T            print variables with traces
  12. #  T <x>        put a write trace on variable <x>
  13. #  X <x>        remove trace on variable <x>
  14.  
  15. # Advanced usage (subject to change):
  16. #  T <x> <how>                put a <how> trace on variable <x>.  How = r(ead), w(rite), or u(nset)
  17. #  T <x> <how> <function>    use <function> instead of _tprint for tracing
  18.  
  19.  
  20. # print traced variable (standard trace function)
  21.  
  22. proc _tprint {n1 n2 op} {
  23.     upvar $n1 value
  24.  
  25.     set level [expr [info level] - 1]
  26.     if {$level > 0} {
  27.         set proc [lindex [info level $level] 0]
  28.     } else {
  29.         set proc Toplevel
  30.     }
  31.     if {$n2 == ""} {
  32.         puts "TRACE: $n1 = $value (in $proc)"
  33.     } else {
  34.         puts "TRACE: ${n1}($n2) = $value($n2) (in $proc)"
  35.     }
  36. }
  37.  
  38. # set [or query] a global variable trace
  39. proc T {{_x_ "?"} {op w} {function _tprint}} {
  40.     global $_x_ _traces
  41.     if {$_x_ == "?"} {
  42.         puts "Current traces:"
  43.         catch "parray _traces"
  44.     } elseif {[info exists _traces($_x_)]} {
  45.         puts "Replacing existing trace for $_x_"
  46.     } else {
  47.         puts "Setting trace for $_x_"
  48.         set _traces($_x_) $op
  49.     }
  50.     eval trace variable $_x_ \$op \$function
  51. }
  52.  
  53. # delete all traces on a variable
  54.  
  55. proc X {{_x_ ?}} {
  56.     global $_x_ _traces
  57.     if {$_x_ == "?"} {
  58.         puts "Usage: X <var_name> (remove trace on var_name>"
  59.         return ""
  60.     }
  61.     catch "unset _traces($_x_)"
  62.     foreach trace [trace vinfo $_x_] {
  63.         puts "Trace remove: $_x_ $trace"
  64.         eval "trace vdelete $_x_ $trace"
  65.     }
  66. }
  67.  
  68. # trace calls to a procedure
  69. # Print proc name, args, calling info
  70.  
  71. proc Trace {{name ?} {stack ""}} {
  72.     if {$name == "?"} {
  73.         puts "Usage: \"Trace <procedure_name>\", toggles the Trace state"
  74.         puts "Procedures being traced:"
  75.         regsub -all {.oLd} [info commands *.oLd] {} list
  76.         puts "  $list"
  77.         return
  78.     }
  79.     if {[info commands $name.oLd] != ""} {
  80.         puts "Untracing $name"
  81.         if {![regexp {!!trace!!} [info body $name]]} {
  82.             puts "OOps, traced version of procedure appears to be gone!"
  83.             rename $name.oLd {}
  84.         } else {
  85.             catch {rename $name ""}
  86.             rename $name.oLd $name
  87.         }
  88.     } else {
  89.         # procedure template
  90.         set template {
  91.             proc %s {args} {
  92.                 # !!trace!!
  93.                 puts "Trace: %s $args"    
  94.                 %s
  95.                 uplevel "%s.oLd $args"
  96.             }
  97.         }
  98.         # template for adding stack trace to procedure
  99.         set stack_template {
  100.             set level [info level]
  101.             while {[incr level -1] > 0} {
  102.                 puts " called from: [info level $level]"
  103.             }
  104.         }
  105.  
  106.         rename $name $name.oLd
  107.         if {$stack == "stack"} {set stack $stack_template} {set stack ""}
  108.         eval [format $template $name $name $stack $name]
  109.         puts "Tracing $name"
  110.     }        
  111. }
  112.  
  113. # simple puts style debugging support
  114.  
  115. proc dputs {args} {
  116.     global Debug Show_stack
  117.     if {![info exists Debug]} {
  118.         return
  119.     }
  120.     set level [expr [info level] - 1]
  121.     if {$level > 0} {
  122.         set caller [lindex [info level $level] 0]
  123.     } else {
  124.         set caller toplevel
  125.     }
  126.  
  127.     # experimental!
  128.  
  129.     if {[info exists Show_stack]} {
  130.         append caller " ("
  131.         while {[incr level -1] > 0} {
  132.             lappend caller [lindex [info level $level] 0]
  133.         }
  134.         append caller ")"
  135.     }
  136.  
  137.     # puts "Debug: $caller in <$Debug> <$args>"
  138.     foreach pattern $Debug {
  139.         if {[string match $pattern $caller]} {
  140.             puts "$caller: $args"
  141.             break
  142.         }
  143.     }
  144. }
  145.